home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / ar.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.0 KB  |  224 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module ar)
  13.  
  14. (declare-top (SPECIAL EVARRP MUNBOUND FLOUNBOUND FIXUNBOUND #+cl $use_fast_arrays))
  15.  
  16. ;;; This code needs to be checked carefully for the lispm.
  17.  
  18.  
  19.  
  20. (defstruct #-cl (mgenarray conc-name array)
  21.        #+cl (mgenarray (:conc-name mgenarray-) (:type vector))
  22.   aref
  23.   aset
  24.   type
  25.   NULL
  26.   GENERATOR
  27.   CONTENT)
  28.  
  29. #-cl
  30. (DEFUN MARRAY-TYPE (X)
  31.   
  32.   (OR (CDR (ASSQ (ARRAY-TYPE X)
  33.          '((FLONUM . $FLOAT)
  34.            (FIXNUM . $FIXNUM))))
  35.       (MGENARRAY-TYPE X)))
  36. #+cl
  37. (DEFUN MARRAY-TYPE (X)
  38.   (case (ml-typep x)
  39.     (array (array-element-type x))
  40.     (hash-table 'hash-table)
  41.     #+lispm (si::equal-hash-table 'hash-table)
  42.     (lisp::array  (princ "confusion over array and lisp::array")
  43.         (array-element-type x))
  44.     (otherwise
  45.  
  46.   (OR (CDR (ASSQ (array-type x)
  47.          '((FLONUM . $FLOAT)
  48.            (FIXNUM . $FIXNUM))))
  49.       (MGENARRAY-TYPE X)))))
  50.  
  51. ;#+lispm
  52. ;(defmfun $Show_hash_array (table)
  53. ;  (send table :map-hash
  54. ;   `(lambda (u v) 
  55. ;    (format t "~%~A-->~A" u v)))
  56. ;  table)
  57.  
  58. (DEFMFUN $MAKE_ARRAY (TYPE &REST DIML)
  59.   (LET ((LTYPE (ASSQ TYPE '(($FLOAT . FLONUM) ($FLONUM . FLONUM)
  60.                           ($FIXNUM . FIXNUM)))))
  61.     (COND ((NOT LTYPE)
  62.        (COND ((EQ TYPE '$ANY)
  63.           #+cl (make-array diml :initial-element nil)
  64.           #-cl
  65.           (MAKE-MGENARRAY  #+cl :type #-cl type  '$ANY
  66.                   #+cl :CONTENT #-cl CONTENT (APPLY '*ARRAY NIL T DIML)))
  67.          ((EQ TYPE '$HASHED)
  68.           (LET ((KLUDGE (GENSYM)))
  69.             (OR (INTEGERP (CAR DIML))
  70.             (MERROR "non-integer number of dimensions: ~M"
  71.                 (CAR DIML)))
  72.             (INSURE-ARRAY-PROPS KLUDGE () (CAR DIML))
  73.             (MAKE-MGENARRAY #+cl :TYPE #-cl TYPE '$HASHED
  74.                     #+cl :CONTENT #-cl CONTENT KLUDGE)))
  75.          ((EQ TYPE '$FUNCTIONAL)
  76.           ;; MAKE_ARRAY('FUNCTIONAL,LAMBDA(...),'ARRAY_TYPE,...)
  77.           (OR (> (LENGTH DIML) 1)
  78.               (MERROR "not enough arguments for functional array specification"))
  79.           (LET ((AR (APPLY #'$MAKE_ARRAY (CDR DIML)))
  80.             (THE-NULL))
  81.             (CASE (MARRAY-TYPE AR)
  82.               (($FIXNUM)
  83.                (FILLARRAY AR (LIST (SETQ THE-NULL FIXUNBOUND))))
  84.               (($FLOAT)
  85.                (FILLARRAY AR (LIST (SETQ THE-NULL FLOUNBOUND))))
  86.               (($ANY)
  87.                (FILLARRAY (MGENARRAY-CONTENT AR) (LIST (SETQ THE-NULL MUNBOUND))))
  88.               (T
  89.                ;; Nothing to do for hashed arrays. Is FUNCTIONAL here
  90.                ;; an error?
  91.                (SETQ THE-NULL 'NOTEXIST)))
  92.             (MAKE-MGENARRAY #+cl :TYPE #-cl TYPE '$FUNCTIONAL
  93.                     #+cl :CONTENT #-cl CONTENT AR
  94.                     #+cl :GENERATOR #-cl GENERATOR (CAR DIML)
  95.                     #+cl :NULL #-cl NULL THE-NULL)))
  96.          ('ELSE
  97.           (MERROR "Array type of ~M is not recognized by MAKE_ARRAY" TYPE))))
  98.       ('ELSE
  99.        (APPLY '*ARRAY NIL (CDR LTYPE) DIML)))))
  100. #+cl
  101. (defmfun maknum (x)
  102.   (cond ($use_fast_arrays
  103.   (exploden (format nil "~A" x)))
  104.     (t (format nil "~A" x))))
  105.  
  106. (DEFMFUN DIMENSION-ARRAY-OBJECT (FORM RESULT &AUX (MTYPE (MARRAY-TYPE FORM)))
  107.   (cond ($use_fast_arrays (dimension-string  (maknum form) result))
  108.     (t
  109.      (DIMENSION-STRING
  110.        (NCONC (EXPLODEN "{Array: ")
  111.           (CDR (EXPLODEN MTYPE))
  112.           (EXPLODEN " ")
  113.           (EXPLODEN (MAKNUM FORM))
  114.           (IF (MEMQ MTYPE '($FLOAT $FIXNUM $ANY))
  115.               (NCONC (EXPLODEN "[")
  116.                  (DO ((L (CDR (ARRAYDIMS (IF (MEMQ MTYPE '($FLOAT $FIXNUM))
  117.                              FORM
  118.                              (MGENARRAY-CONTENT FORM))))
  119.                      (CDR L))
  120.                   (V NIL
  121.                      (NCONC (NREVERSE (EXPLODEN (CAR L))) V)))
  122.                  ((NULL L) (NREVERSE V))
  123.                    (IF V (PUSH #\, V)))
  124.                  (EXPLODEN "]")))
  125.           (EXPLODEN "}"))
  126.        RESULT))))
  127.  
  128.  
  129.  
  130. (DEFUN MARRAY-CHECK (A)
  131.   (IF (EQ (ml-typep A) 'array)
  132.       (CASE (MARRAY-TYPE A)
  133.     ((art-q ) a)
  134.     (($FIXNUM $FLOAT) A)
  135.     (($ANY) (MGENARRAY-CONTENT A))
  136.     (($HASHED $FUNCTIONAL)
  137.     
  138.      ;; BUG: It does have a number of dimensions! Gosh. -GJC
  139.      (MERROR "Hashed array has no dimension info: ~M" A))
  140.     (T
  141.      (MARRAY-TYPE-UNKNOWN A)))
  142.       (MERROR "Not an array: ~M" A)))
  143.  
  144. (DEFMFUN $ARRAY_NUMBER_OF_DIMENSIONS (A)
  145.   (ARRAY-/#-DIMS (MARRAY-CHECK A)))
  146.  
  147. (DEFMFUN $ARRAY_DIMENSION_N (N A)
  148.   #-cl(ARRAY-DIMENSION-N N (MARRAY-CHECK A))
  149.   #+cl(array-dimension  (MARRAY-CHECK A) n)
  150.   )
  151.  
  152. (DEFUN MARRAY-TYPE-UNKNOWN (X)
  153.   (MERROR "BUG: Array of unhandled type: ~S" X))
  154.  
  155. (DEFUN MARRAYREF-GENSUB (AARRAY IND1 INDS)  
  156.        (CASE (MARRAY-TYPE AARRAY)
  157.     ;; We are using a CASE on the TYPE instead of a FUNCALL, (or SUBRCALL)
  158.     ;; because we are losers. All this stuff uses too many functions from
  159.     ;; the "MLISP" modual, which are not really suitable for the kind of
  160.     ;; speed and simplicity we want anyway. Ah me. Also, passing the single
  161.     ;; unconsed index IND1 around is a dubious optimization, which causes
  162.     ;; extra consing in the case of hashed arrays.
  163. #+cl((t) (apply #'aref aarray ind1 inds))
  164. #+cl((hash-table) (gethash (if inds (cons ind1 inds) ind1) aarray))
  165.     (($HASHED)
  166.      (APPLY #'MARRAYREF (MGENARRAY-CONTENT AARRAY) IND1 INDS))
  167.     (($FLOAT $FIXNUM)
  168.      (APPLY AARRAY IND1 INDS))
  169.     (($ANY)
  170.      (APPLY (MGENARRAY-CONTENT AARRAY) IND1 INDS))
  171.     (($FUNCTIONAL)
  172.      (LET ((VALUE (LET ((EVARRP T))
  173.             ;; special variable changes behavior of hashed-array
  174.             ;; referencing functions in case of not finding an element.
  175.             (CATCH 'EVARRP (MARRAYREF-GENSUB
  176.                       (MGENARRAY-CONTENT AARRAY) IND1 INDS)))))
  177.        (IF (EQUAL VALUE (MGENARRAY-NULL AARRAY))
  178.        (MARRAYSET-GENSUB  (APPLY #'MFUNCALL
  179.                          (MGENARRAY-GENERATOR AARRAY)
  180.                          ;; the first argument we pass the
  181.                          ;; function is a SELF variable.
  182.                          AARRAY
  183.                          ;; extra consing here! LEXPR madness.
  184.                          IND1
  185.                          INDS)
  186.                   (MGENARRAY-CONTENT AARRAY) IND1 INDS)
  187.        VALUE)))
  188.     (T
  189.      (MARRAY-TYPE-UNKNOWN AARRAY))))
  190.       
  191. (defmfun $Make_art_q (&rest l)
  192.     (make-array l))
  193.  
  194. (DEFUN MARRAYSET-GENSUB (VAL AARRAY IND1 INDS) 
  195.   (CASE (MARRAY-TYPE AARRAY)
  196.     #+cl
  197.     ((t) (setf (apply #'aref aarray ind1 inds) val))
  198.     (($HASHED)
  199.      (APPLY #'MARRAYSET VAL (MGENARRAY-CONTENT AARRAY) IND1 INDS))
  200.     (($ANY)
  201.      #-cl(STORE (APPLY (MGENARRAY-CONTENT AARRAY) IND1 INDS) VAL)
  202.      #+cl
  203.      (setf (apply #'Aref (MGENARRAY-CONTENT AARRAY) IND1 INDS) val ))
  204.      
  205.     (($FLOAT $FIXNUM)
  206.      #-cl(STORE (APPLY AARRAY IND1 INDS) VAL)
  207.      #+cl     (setf  (apply #'Aref (MGENARRAY-CONTENT AARRAY) IND1 INDS) val ))
  208.     (($FUNCTIONAL)
  209.      (MARRAYSET-GENSUB VAL (MGENARRAY-CONTENT AARRAY) IND1 INDS))
  210.     (T
  211.       (MARRAY-TYPE-UNKNOWN AARRAY))))
  212.  
  213.  
  214. ;; Extensions to MEVAL.
  215.  
  216. (DEFMFUN MEVAL1-EXTEND (FORM)
  217.   (LET ((L (MEVALARGS (CDR FORM))))
  218.     (MARRAYREF-GENSUB (CAAR FORM) (CAR L) (CDR L))))
  219.  
  220. (DEFMFUN ARRSTORE-EXTEND (A L R)
  221.   (MARRAYSET-GENSUB R A (CAR L) (CDR L)))
  222.  
  223.  
  224.